(make-package 'netpbm)
(use-package 'netpbm)

(defstruct header
  (type 0 :type integer)
  (height 0 :type integer)
  (width 0 :type integer)
  (maxval 0 :type integer)
  (depth 1 :type integer)
  (sample-size 1 :type integer)
  (current-row 0 :type integer)
  (tupltype "" :type string)
  (direction 'huh? :type symbol)
  stream)

(defun new-header (width height channels maxval)
  (if (not (and (integerp width) (integerp height) (integerp maxval) (< maxval 65536)))
      (error "new-header: width, height, and maxval must be integers, maxval must be less than 65536"))
  (make-header :type (cond ((= channels 1) 5)
			   ((= channels 3) 6)
			   (t (error (format nil "cannot make header with ~a channels" channels))))
	       :height height
	       :width width
	       :depth channels
	       :maxval maxval
	       :sample-size (if (< maxval 256) 1 2)))

(defun copy-header (h)
  (make-header :type (header-type h)
	       :height (header-height h)
	       :width (header-width h)
	       :depth (header-depth h)
	       :maxval (header-maxval h)
	       :sample-size (header-sample-size h)))

(defun read-header (stream) ;need regexes
  (if (not (eql (read-char stream) #\P)) (error "not a pnm"))
  (let ((type (parse-integer (string (read-char stream)))))
    (cond 
     ((or (= type 6) (= type 5))
      (let* ((width (read stream)) (height (read stream)) (maxval (read stream))
	     (h (new-header width height (if (= type 6) 3 1) maxval)))
	(setf (header-stream h) stream)
	(setf (header-direction h) 'in)
	h))
     (t (error "netpbm can only handle type 5 and 6 right now")))))

(defun make-row (h)
  (make-array (list (header-width h) (header-depth h))))

(defun read-row (h)
  (if (not (eq (header-direction h) 'in)) (error "read-row: cannot read in with output header"))
  (if (= (header-current-row h) (header-height h)) nil
    (let* ((num (* (header-depth h) (header-width h)))
	   (stream (header-stream h))
	   (array (make-array (list (header-width h) (header-depth h))))
	   (flat-array (make-array num :displaced-to array)))
      (incf (header-current-row h))
      (if (= (header-sample-size h) 1) 
	  (dotimes (n num array) 
	    (setf (aref flat-array n) (char-code (read-char stream))))
	  (dotimes (n num array) 
	    (setf (aref flat-array n) 
		  (+ (* 255 (char-code (read-char stream))) 
		     (char-code (read-char stream)))))))))

(defun write-header (h stream)
  (if (not (eq (header-direction h) 'huh?)) 
      (error "cannot write out a header already used for reading/writing"))
  (if (not (or (= (header-type h) 5) (= (header-type h) 6)))
      (error "netpbm can only handle type 6 right now"))
  (format stream "P~a~%~a ~a~%~a~%" (header-type h) (header-width h) 
	  (header-height h) (header-maxval h))
  (setf (header-direction h) 'out)
  (setf (header-stream h) stream)
  t)

(defun write-row (h a)
  (if (not (eq (header-direction h) 'out)) (error "write-row: cannot write out with input header"))
  (let ((dims (array-dimensions a))
	(width (header-width h))
	(depth (header-depth h))
	(stream (header-stream h)))
    (if (not (and (= (first dims) width) (= (second dims) depth))) 
	(error "write-row: dimensions do not match"))
    (let* ((size (* width depth))
	   (flat-array (make-array size :displaced-to a)))
      (if (= (header-sample-size h) 1) 
	  (dotimes (n size t) (write-char (code-char (aref flat-array n)) stream))
	  (dotimes (n size t) 
	    (write-char (code-char (/ (aref flat-array n) 256)) stream)
	    (write-char (code-char (mod (aref flat-array n) 256)) stream))))))

(defun stream-image (f inh outh)
  (let ((indepth (header-depth inh)) (outdepth (header-depth outh))
	(row-length (min (header-width inh) (header-width outh))))
    (do ((inrow (read-row inh) (read-row inh))
	 (outrow (make-row outh)))
	((null inrow))
	(dotimes (n row-length t) 
	  (funcall f (make-array indepth :displaced-to inrow 
				 :displaced-index-offset (array-row-major-index inrow n 0))
		   (make-array outdepth :displaced-to outrow
			       :displaced-index-offset (array-row-major-index outrow n 0))))
	(write-row outh outrow)))
  (finish-output (header-stream outh)))
      